﻿<%
'''邮件发送类
Class MailClass
	'SMTP邮件服务器地址,邮件服务器登录名,登录密码,发件人邮箱,发送人名称,邮件类型,编码类型
	Public SMTP, LoginName, LoginPass, FromMail, FromName, ContentType, Charset
	'收件人地址,邮件主题,邮件内容,邮件等级(-1低级,0默认,1加急), 端口, 域
	Public ToMail, Subject, Content, Priority, Port, Domain
	'当前Mail组件1=Jmail,2=Aspemail,3=Cdonts,4=Cdoemail
	Private s_objmail
	'错误代码,组件错误信息
	Private s_iCode, s_iMsg
	'JMail,Persits,CDONTS,CDO组件名,CDO设置名
	Private s_jName, s_pName, s_nName, s_cName, s_fName
	
	'''构造
	Private Sub Class_Initialize()
		s_objmail = 1
		ContentType = "text/html"
		Charset = "UTF-8"
		Priority = 0
		Port = 25
		Domain = ""
		s_iCode = 0
		s_iMsg = ""
		s_jName = "JMail.Message"
		s_pName = "Persits.MailSender"
		s_nName = "CDONTS.NewMail"
		s_cName = "CDO.Message"
		s_fName = "CDO.Configuration"
	End Sub

	'''析构
	Private Sub Class_Terminate()
	End Sub

	'''根据不同的mail对象返回邮件等级
	'p_o:1=Jmail,2=Aspemail,3=Cdonts,4=Cdoemail
	Private Function formatPri_(Byval p_o)
		Select Case p_o
		Case 1,2,4
			formatPri_ = 3 - 2*Priority
		Case 3
			formatPri_ = Priority + 1
		Case Else
			formatPri_ = Priority
		End Select
	End Function
	
	'设置优先选取组件(可读/写) 1=Jmail,2=Aspemail,3=Cdonts,4=Cdoemail
	'p_s:组件名或缩写或特征值
	Public Property Let [Object](Byval p_s)
		Select Case LCase(Cstr(p_s))
		Case "1","jmail","jmail.message"
			s_objmail = 1
		Case "2","aspemail","persits.mailsender"
			s_objmail = 2
		Case "3", "cdonts","cdonts.newmail"
			s_objmail = 3
		Case "4","cdomail","cdo.message"
			s_objmail = 4
		Case Else
			s_objmail = p_s
		End Select
	End Property
	
	'''获取当前组件名进行组件本体操作
	Public Property Get [Object]()
		Dim t_s
		Select Case LCase(Cstr(s_objmail))
		Case "1","jmail","jmail.message"
			t_s = s_jName
		Case "2","aspemail","persits.mailsender"
			t_s = s_pName
		Case "3", "cdonts","cdonts.newmail"
			t_s = s_nName
		Case "4","cdomail","cdo.message"
			t_s = s_cName
		Case Else
			t_s = s_objmail
		End Select
		[Object] = t_s
	End Property
	
	'''错误代码,为0为不出错
	Public Property Get Code()
		Code = s_iCode
	End Property

	'''系统错误信息
	Public Property Get [Error]()
		[Error] = s_iMsg
	End Property
	
	'以数组形式获取收信人地址或姓名
	'p_m:一定格式的字符串或数组
	'p_t:当=0时返回(收信人地址)数组; 当=1时返回(收信人姓名)数组
	Private Function mailArray_(Byval p_m, Byval p_t)
		Dim t_a(),t_b()
		Dim t_m,t_n,t_i,t_k : t_m = p_m
		Dim t_s1,t_s2,t_t1,t_t2,t_t
		If Not IsArray(t_m) Then
			If IsNull(t_m) Or Trim(t_m)="" Then
				mailArray_ = t_a
				Exit Function
			End If
		End If
		If IsN(t_m) Then
			mailArray_ = t_a
			Exit Function
		End If
		If IsArray(t_m) Then
			t_n = t_m
		Else
			If InStr(t_m,";")>0 Then
				If InStrRev(t_m,";")=Len(t_m) Then
					t_m = Left(t_m,len(t_m)-1)
				End If
				t_n = Split(t_m,";")
			Else
				t_n = Array(t_m)
			End If
		End If
		If IsArray(t_n) Then
			t_k = 0
			Dim t_r : Set t_r = New RegExp
			t_r.IgnoreCase = True
			t_r.Global = True
			For t_i=0 to UBound(t_n)
				If Not IsNull(t_n(t_i)) And Trim(t_n(t_i))<>"" Then
					t_t = Trim(t_n(t_i))
					t_r.Pattern = "^[^<>]*[<]?([^<>]*)[>]?"
					t_t1 = t_r.Replace(t_t,"$1")
					t_r.Pattern = "^\s*[""|']?\s*([^""']*)\s*[""|']?\s*"
					t_t2 = t_r.Replace(t_t,"$1")
					If Instr(t_t,"<")<=0 Then
						t_s1 = t_t
					Else
						t_s1 = Trim(t_t1)
					End If
					t_s2 = Trim(t_t2)
					If t_s1 <> "" Then
						Redim Preserve t_a(t_k)
						Redim Preserve t_b(t_k)
						t_a(t_k) = t_s1
						t_b(t_k) = t_s2
						t_k = t_k + 1
					End If
				End If
			Next
			Set t_r = Nothing
		End If
		Select Case LCase(Cstr(p_t))
		Case "1"
			mailArray_ = t_b
		Case Else
			mailArray_ = t_a
		End Select
	End Function
	
	'''检查参数合法性,返回错误代码
	'p_o:组件特征值
	Private Function checkPara_(Byval p_o)
		checkPara_ = 0
		If Trim(SMTP) = "" Then
			checkPara_ = 1
			Exit Function
		End If
		If Trim(LoginName) = "" Then
			checkPara_ = 2
			Exit Function
		End If
		If Trim(LoginPass) = "" Then
			checkPara_ = 3
			Exit Function
		End If
		If Trim(FromMail) = "" Then
			checkPara_ = 4
			Exit Function
		End If
		If IsN(ToMail) Then
			checkPara_ = 5
			Exit Function
		End If
		If Subject = "" Then
			Subject = "无主题."
		End If
		Select Case p_o
		Case 1
			If Not IsInstall(s_jName) Then
				checkPara_ = 11
				Exit Function
			End If
		Case 2
			If Not IsInstall(s_pName) Then
				checkPara_ = 12
				Exit Function
			End If
		Case 3
			If Not IsInstall(s_nName) Then
				checkPara_ = 13
				Exit Function
			End If
		Case 4
			If Not (IsInstall(s_cName) And IsInstall(s_fName)) Then
				checkPara_ = 14
				Exit Function
			End If
		End Select
	End Function
	
	'''使用JMail.Message发送邮件
	Private Sub jMail_()
		On Error Resume Next
		s_iCode = checkPara_(1)
		If s_iCode <> 0 Then
			Exit Sub
		End If
		Dim t_ma, t_na, t_i, t_o
		Set t_o = Server.CreateObject(s_jName)
		t_o.Silent = True
		t_o.Charset = Charset
		t_o.ContentType = ContentType
		t_o.From = FromMail
		t_o.FromName = FromName
		t_o.MailServerUserName = LoginName
		t_o.MailServerPassword = LoginPass
		If Domain <> "" Then
			t_o.MailDomain = Domain
		End If
		t_ma = mailArray_(ToMail,0)
		t_na = mailArray_(ToMail,1)
		For t_i = 0 To UBound(t_ma)
			If Trim(t_na(t_i))<>"" Then
				t_o.AddRecipient t_ma(t_i), t_na(t_i)
			Else
				t_o.AddRecipient t_ma(t_i)
			End If
		Next
		If t_o.Recipients.Count=0 Then
			s_iCode = 5
			Exit Sub
		End If
		t_o.Subject = Subject
		If Lcase(ContentType) = "text/html" Then
			t_o.HTMLBody = Content
		Else
			t_o.Body = Content
		End If
		t_o.Priority = formatPri_(1)
		t_o.Send(SMTP & IfThen(Port<>25,":"&Port))
		t_o.ClearRecipients()
		s_iMsg = t_o.ErrorMessage
		If t_o.ErrorMessage<>"" Then
			s_iCode = -1
		End If
		t_o.Close()
		Set t_o = Nothing
		If Err<>0 Then
			s_iCode = -1
		End If
	End Sub
	
	'''使用Persits.MailSender发送邮件
	Private Sub aspEmail_()
		On Error Resume Next
		s_iCode = checkPara_(2)
		If s_iCode <> 0 Then
			Exit Sub
		End If
		Dim t_o : Set t_o = Server.CreateObject(s_pName)
		t_o.From = FromMail
		t_o.FromName = FromName
		t_o.Subject = Subject
		t_o.Body = Content
		t_o.Charset = Charset
		If Lcase(ContentType) = "text/html" Then
			t_o.IsHTML = True
		Else
			t_o.IsHTML = False
		End If
		t_o.UserName = LoginName
		t_o.PassWord = LoginPass
		t_o.Priority = formatPri_(2)
		t_o.Host = SMTP
		If Port <> 25 Then
			t_o.Port = Port
		End If
		Dim t_ma, t_na, t_i
		t_ma = mailArray_(ToMail,0)
		t_na = mailArray_(ToMail,1)
		For t_i = 0 To UBound(t_ma)
			If Trim(t_na(t_i))<>"" Then
				t_o.AddAddress t_ma(t_i), t_na(t_i)
			Else
				t_o.AddAddress t_ma(t_i)
			End If
		Next
		t_o.Send
		If Err<>0 Then
			s_iCode = -2
			s_iMsg = Err.Description
		End If
	End Sub
	
	'''使用CDONTS.NewMail发送邮件,需要服务器环境支持
	Private Sub cdontsNmail_()
		On Error Resume Next
		s_iCode = checkPara_(3)
		If s_iCode <> 0 Then
			Exit Sub
		End If
		Dim t_o : Set t_o = Server.CreateObject(s_cName)
		t_o.From = FromMail
		t_o.Subject = Subject
		If Lcase(ContentType) = "text/html" Then
			t_o.BodyFormat = 0
			t_o.MailFormat = 0
		End If
		t_o.Importance = formatPri_(3)
		t_o.Body = Content
		Dim t_i,t_ma : t_ma = mailArray_(ToMail,0)
		For t_i = 0 To UBound(t_ma)
			t_o.To = t_ma(t_i)
			t_o.Send
		Next
		If Err<>0 Then
			s_iCode = -3
			s_iMsg = Err.Description
		End If
	End Sub
	
	'''返回CDO.Configuration
	Private Function cdoConfig_()
		Dim t_s, t_m, t_v, t_p, t_t, t_a, t_u, t_w, t_n, t_f, t_r
		t_s = "http://schemas.microsoft.com/cdo/configuration/"
		t_m = t_s & "sendusing"
		t_v = t_s & "smtpserver"
		t_p = t_s & "smtpserverport"
		t_t = t_s & "smtpconnectiontimeout"
		t_a = t_s & "smtpauthenticate"
		t_n = t_s & "smtpaccountname"
		t_f = t_s & "sendemailaddress"
		t_r = t_s & "smtpuserreplyemailaddress"
		t_u = t_s & "sendusername"
		t_w = t_s & "sendpassword"
		Dim t_o : Set t_o = Server.CreateObject(s_fName)
		With t_o.Fields 
			.Item(t_m) = 2
			.Item(t_v) = SMTP
			.Item(t_p) = Port
			.Item(t_t) = 10
			.Item(t_a) = 1
			.Item(t_n) = FromName
			.Item(t_f) = FromMail
			.Item(t_u) = LoginName
			.Item(t_w) = LoginPass
			.Update 
		End With
		Set cdoConfig_ = t_o
	End Function
	
	'''使用CDO.Message发送邮件
	Private Sub cdoMessage_()
		On Error Resume Next
		s_iCode = checkPara_(4)
		If s_iCode <> 0 Then
			Exit Sub
		End If
		Dim t_c : Set t_c = cdoConfig_()
		Dim t_o : Set t_o = Server.CreateObject(s_cName)
		With t_o
			Set .Configuration = t_c
			.BodyPart.Charset = Charset
			.From = FromMail
			.Subject = Subject
			If Lcase(ContentType) = "text/html" Then
				.HtmlBody = Content
			Else
				.TextBody = Content
			End If
		End With
		Dim t_ma, t_na
		t_ma = mailArray_(ToMail,0)
		t_na = mailArray_(ToMail,1)
		For t_i = 0 To UBound(t_ma)
			If Trim(t_na(t_i))<>"" Then
				t_o.To = """"& t_na(t_i) &""" <"& t_ma(t_i) &">"
			Else
				t_o.To = t_ma(t_i)
			End If
			t_o.Send
		Next
		Set t_c = Nothing
		If Err<>0 Then
			s_iCode = -4
			s_iMsg = Err.Description
		End If
	End Sub
	
	'''底层发送邮件,如果使用其他组件使用Object自行编写
	'p_c:是否穷举强制发送(尝试所有组件发送知道成功)
	Private Sub sendMail_(Byval p_c)
		On Error Resume Next
		Select Case s_objmail
		Case 1
			jMail_()
		Case 2
			aspEmail_()
		Case 3
			cdontsNmail_()
		Case 4
			cdoMessage_()
		Case Else
			s_iCode = -5
		End Select
		If p_c And s_iCode<>0 Then
			Dim t_i, t_fa : t_fa = Array("jMail_", "aspEmail_", "cdontsNmail_", "cdoMessage_")
			For t_i = 0 To UBound(t_fa)
				s_objmail = t_i + 1
				Execute(t_fa(t_i) & "()")
				If s_iCode = 0 Then
					Exit Sub
				End If
			Next
		End If
		If Err<>0 Then
			s_iCode = -100
			s_iMsg = Err.Description
		End If
	End Sub
	
	'''发送邮件
	Public Sub Send()
		sendMail_(False)
	End Sub
	
	'''穷举发送邮件
	Public Sub CSend()
		sendMail_(True)
	End Sub
End Class
%>